home *** CD-ROM | disk | FTP | other *** search
/ MacWorld UK 2000 March / MW_UK_2000_03.iso / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menus.tcl < prev    next >
Encoding:
Text File  |  1999-11-16  |  26.4 KB  |  950 lines  |  [TEXT/ALFA]
  1. # Menu creation procs
  2.     
  3. namespace eval menu {}
  4. namespace eval global {}
  5. namespace eval file {}
  6.  
  7. proc menu::buildBasic {} {
  8.     global winMenu HOME
  9.     # These are built on the fly
  10.     Menu -n File -p menu::generalProc {}
  11.     Menu -n Edit -p menu::generalProc {}
  12.     Menu -n Text -p menu::generalProc {}
  13.     Menu -n Search {}
  14.     Menu -n Utils {}
  15.     Menu -n Config {}
  16.     Menu -n $winMenu {}
  17.     
  18.     insertMenu "File"
  19.     insertMenu "Edit"
  20.     insertMenu "Text"
  21.     insertMenu "Search"
  22.     insertMenu "Utils"
  23.     insertMenu "Config"
  24.     insertMenu $winMenu
  25.     
  26.     if {![catch {glob -dir [file join $HOME Help] *} files]} {
  27.     set men { "Alpha Manual" "Quick Start" "Alpha Commands" "Tcl Commands" \
  28.       "(-" "Readme" "Changes" \
  29.       "Extending Alpha" "Bug Reports and Debugging" "(-" }
  30.     foreach f $men {
  31.         if {$f != "(-" && ![file exists [file join ${HOME} Help $f]]} {
  32.         set men [lremove $men $f]
  33.         }
  34.     }
  35.     set ignore "" 
  36.     foreach f [lsort $files] {
  37.         set f [file tail $f]
  38.         if {[lsearch $men $f] < 0 && [lsearch $ignore $f] < 0} {
  39.         lappend men $f
  40.         }
  41.     }
  42.     regsub -all {\(-[ \t\r\n]+\(-} $men {\(-} men
  43.     foreach f $men {
  44.         addHelpMenu $f
  45.     }
  46.     }
  47.     
  48. }
  49.  
  50. proc menu::buildwinMenu {} {
  51.     global winMenu winNameToNum
  52.     set ma {
  53.     "//<Szoom"
  54.     "//<S<I<OdefaultSize"
  55.     "<S/;chooseAWindow"
  56.     "/I<Biconify"
  57.     {Menu -n arrange -p menu::winTileProc {
  58.         "/Jvertically^1"
  59.         "/J<O<Ihorizontally^2"
  60.         "/J<B<OunequalVert^6"
  61.         "/J<B<I<OunequalHor^5"
  62.         "(-"
  63.         {Menu -n other {
  64.         {bufferOtherWindow}
  65.         {iconify}
  66.         {nextWin}
  67.         {nextWindow}
  68.         {prevWindow}
  69.         {shrinkFull}
  70.         {shrinkHigh}
  71.         {shrinkLeft}
  72.         {shrinkLow}
  73.         {shrinkRight}
  74.         {defaultSize}
  75.         {swapWithNext}
  76.         {zoom}
  77.         }}}
  78.     }
  79.     "(-"
  80.     "/msplitWindow"
  81.     "/otoggleScrollbar"
  82.     "(-"
  83.     }
  84.     # We may be reloading, so add whatever windows we have
  85.     if {[info exists winNameToNum]} {
  86.     set nms [array names winNameToNum]
  87.     foreach name $nms {
  88.         set item [file tail $name]
  89.         set num $winNameToNum($name)
  90.         if {$num < 10}     {
  91.         lappend ma /$num${item}
  92.         } else {
  93.         lappend ma ${item}
  94.         }
  95.     }
  96.     }
  97.     return [list "build" $ma menu::winProc "" $winMenu]
  98. }
  99.  
  100. proc global::listAllBindings {} {
  101.     new -n {* All Key Bindings *} -m Tcl -info [bindingList]
  102. }
  103.  
  104. proc global::listGlobalBindings {} {
  105.     global mode::features
  106.     set text ""
  107.     set tmp [lsort -ignore [array names mode::features]]
  108.     foreach b [split [bindingList] "\r"] {
  109.     set lst [lindex [split $b  " "] end]
  110.     if {[lsearch $tmp $lst] < 0} {
  111.         append text "$b\r"
  112.     }
  113.     }
  114.     new -n {* Global Key Bindings *} -m Tcl -info $text
  115. }
  116.  
  117. proc global::listPackages {} {
  118.     global index::feature
  119.     cache::readContents index::maintainer
  120.     foreach i [array names index::maintainer] {
  121.     set j [lindex [set index::maintainer($i)] 1]
  122.     set au($i) "[lindex $j 0], [lindex $j 1]"
  123.     }
  124.     new -n {* Installed Packages *} -m Text
  125.     append t "Currently installed packages\r\r"
  126.     append t "columns are: name, version, and maintainer\r"
  127.     append t "\r\rMenus:"
  128.     insertText $t ; set t ""
  129.     foreach p [lsort -ignore [array names index::feature]] {
  130.     set v [alpha::package versions $p]
  131.     if {[lindex $v 0] == "mode"} {
  132.         set v "for [lindex $v 1] mode"
  133.     }
  134.     switch -- [lindex [set index::feature($p)] 2] {
  135.         "1" {
  136.         append tm "\r[format {  %-25s %-10s  } $p $v]"
  137.         if {[info exists au($p)]} {append tm $au($p)}
  138.         }
  139.         "0" {
  140.         append tp "\r[format {%s %-25s %-10s  } [package::active $p {• { }}] $p $v]"
  141.         if {[info exists au($p)]} {append tp $au($p)}
  142.         }
  143.         "-1" {
  144.         append ta "\r[format {  %-25s %-10s  } $p $v]"
  145.         if {[info exists au($p)]} {append ta $au($p)}
  146.         }
  147.     }
  148.     }
  149.     if {[info exists tm]} {insertText $tm ; unset tm}
  150.     insertText "\r\rFeatures ('•' = active):"
  151.     if {[info exists tp]} {insertText $tp ; unset tp}
  152.     insertText "\r\rAuto-loading features:"
  153.     if {[info exists ta]} {insertText $ta ; unset ta}
  154.     append t "\r\rModes:"
  155.     insertText $t ; set t ""
  156.     foreach p [lsort -ignore [alpha::package names -mode]] {
  157.     set v [alpha::package versions $p]
  158.     if {[lindex $v 0] == "mode"} {
  159.         set v "for [lindex $v 1] mode"
  160.     }
  161.     append t "\r[format {  %-8s %-10s  } $p $v]"
  162.     if {[info exists au($p)]} {append t $au($p)}
  163.     }
  164.     insertText $t ; set t ""
  165.     winReadOnly
  166.     shrinkWindow
  167. }
  168.  
  169. proc global::listFunctions {} {
  170.     global win::Modes
  171.     new -n {* Functions *} -m Tcl -info \
  172.       "===\r\tCommand-double-click on a function to see its definition\r===\r\r[join [lsort -ignore [info commands]] \r]\r"
  173. }
  174.  
  175. proc global::menusAndFeatures {} {
  176.     global global::features mode::features mode
  177.     
  178.     set newGlobals [dialog::pickMenusAndFeatures global]
  179.     set offon [package::onOrOff $newGlobals $mode 1]
  180.  
  181.     set global::features $newGlobals
  182.     # remove removed menus
  183.     foreach m [lindex $offon 0] {
  184.     package::deactivate $m
  185.     }
  186.     foreach m [lindex $offon 1] {
  187.     package::activate $m
  188.     }
  189. }
  190.  
  191. proc global::insertAllMenus {} {
  192.     global global::features index::feature
  193.     foreach m ${global::features} {
  194.     if {[lindex [set index::feature($m)] 2] == 1} {
  195.         global $m
  196.         insertMenu [set $m]
  197.     }
  198.     }
  199. }
  200.  
  201. proc global::rebuildPackageIndices {} {
  202.     if {[dialog::yesno "You must quit Alpha immediately after rebuilding. \
  203.       Proceed?"]} {
  204.     alpha::rebuildPackageIndices
  205.     }
  206. }
  207.  
  208. ## 
  209.  # -------------------------------------------------------------------------
  210.  # 
  211.  # "menu::buildProc" --
  212.  # 
  213.  #  Register a procedure to be the 'build proc' for a given menu.  This
  214.  #  procedure can do one of two things:
  215.  #  
  216.  #  i) build the entire menu, including evaluating the 'menu ...' command.
  217.  #  In this case the build proc should return anything which doesn't
  218.  #  begin 'build ...'
  219.  #  
  220.  #  ii) build up part of the menu, and then allow pre-registered menu
  221.  #  insertions/replacements to take-effect.  In this case the procedure
  222.  #  should return a list of the items (listed by index):
  223.  #  
  224.  #  0: "build"
  225.  #  1: list-of-items-in-the-menu
  226.  #  2: list of other flags.  If the list doesn't contain '-p', we use
  227.  #  the standard menu::generalProc procedure.  If it does contain '-p'
  228.  #  general prmenu procedure to call when an item is selected.  
  229.  #  If nothing is given,
  230.  #  or if '-1' is given, then we don't have a procedure.  If "" is given,
  231.  #  we use the standard 'menu::generalProc' procedure.  Else we use the
  232.  #  given procedure.
  233.  #  3: list of submenus which need building.
  234.  #  4: over-ride for the name of the menu.
  235.  #  
  236.  #  You must register the build-proc before attempting to build the menu.
  237.  #  Once registered, any call of 'menu::buildSome name' will build your
  238.  #  menu.
  239.  # -------------------------------------------------------------------------
  240.  ##
  241. proc menu::buildProc {name proc} {
  242.     global menu::build_procs
  243.     set menu::build_procs($name) $proc
  244. }
  245.  
  246. ## 
  247.  # -------------------------------------------------------------------------
  248.  # 
  249.  # "menu::insert" --
  250.  # 
  251.  #  name, type, where, then list of items.  type = 'items' 'submenu'
  252.  #  
  253.  #  Add given items to a given menu, provided they are not already there.
  254.  #  Rebuild that menu if necessary.
  255.  #  
  256.  #  There are also procs 'menu::removeFrom' which does the opposite of
  257.  #  this one, and 'menu::replaceWith' which replaces a given menu item
  258.  #  with others.
  259.  # -------------------------------------------------------------------------
  260.  ##
  261. proc menu::insert {name args} {
  262.     if {[llength $args] < 3} { error "Too few args to menu::insert" }
  263.     global menu::additions alpha::noMenusYet
  264.     if {[info exists menu::additions($name)]} {
  265.     set a [set menu::additions($name)]
  266.     if {[lsearch -exact $a $args] != -1} { 
  267.         return 
  268.     }
  269.     # check if it's there but in a different place; we over-ride
  270.     set dblchk [lreplace $args 1 1 "*"]
  271.     if {[set i [lsearch -glob $a $dblchk]] == -1} {
  272.         unset i
  273.     }
  274.     }
  275.     if {[info exists i]} {
  276.     set menu::additions($name) [lreplace $a $i $i $args]
  277.     } else {
  278.     lappend menu::additions($name) $args
  279.     }
  280.     if {![info exists alpha::noMenusYet]} {
  281.     # we were called after start-up; build the menu now
  282.     menu::buildSome $name
  283.     }
  284. }
  285.  
  286. proc menu::uninsert {name args} {
  287.     global menu::additions alpha::noMenusYet
  288.     set a [set menu::additions($name)]
  289.     if {[set idx [lsearch -exact $a $args]] == -1} { 
  290.     return 
  291.     }
  292.     set menu::additions($name) [lreplace $a $idx $idx]
  293.     if {![info exists alpha::noMenusYet]} {
  294.     # we were called after start-up; build the menu now
  295.     menu::buildSome $name
  296.     }
  297. }
  298.  
  299. proc alpha::buildMainMenus {} {
  300.     menu::buildProc internetUpdates package::makeUpdateMenu
  301.     menu::buildProc packages menu::packagesBuild
  302.     menu::buildProc mode menu::modeBuild
  303.     menu::buildProc winMenu menu::buildwinMenu
  304.     menu::buildProc preferences menu::preferencesBuild
  305.     uplevel #0 {
  306.     source [file join $HOME Tcl SystemCode alphaMenus.tcl]
  307.     menu::buildSome "File" "Edit" "Text" "Search" "Utils" "Config" "winMenu"
  308.     }
  309. }
  310.  
  311. ## 
  312.  # -------------------------------------------------------------------------
  313.  # 
  314.  # "menu::buildSome" --
  315.  # 
  316.  #  Important procedure which builds all known/registered menus from a
  317.  #  number of pieces.  It allows the inclusion of menus pieces registered
  318.  #  with the menu::insert procedure, which allows you easily to add items
  319.  #  (including dynamic and hierarchial) to any of Alpha's menus.
  320.  # 
  321.  # Results:
  322.  #  Various menus are (re)built
  323.  # 
  324.  # Side effects:
  325.  #  Items added to those menus with 'addMenuItem' will vanish.
  326.  # 
  327.  # --Version--Author------------------Changes-------------------------------
  328.  #    1.0     <vince@santafe.edu> original
  329.  #    2.0     <vince@santafe.edu> more compact, more like tk
  330.  # -------------------------------------------------------------------------
  331.  ##
  332. proc menu::buildSome {args} {
  333.     set msubs {}
  334.     foreach token $args {
  335.     eval lappend msubs [menu::buildOne $token]
  336.     }
  337.     # build sub-menus of those built
  338.     if {[llength $msubs]} {eval menu::buildSome $msubs}
  339. }
  340.  
  341. proc menu::buildOne {args} {
  342.     global menu::additions menu::build_procs alpha::noMenusYet \
  343.       menu::items
  344.     set token [lindex $args 0] ; set args [lrange $args 1 end]
  345.     if {[set len [llength $args]] > 0 || [info exists menu::build_procs($token)]} {
  346.     if {$len > 0} {
  347.         set res $args
  348.     } else {
  349.         if {[catch "[set menu::build_procs($token)]" res]} {
  350.         alpha::reportError "The menu $token had a problem starting up ; $res"
  351.         }
  352.     }
  353.     switch -- [lindex $res 0] {
  354.         "build" {
  355.         set ma [lindex $res 1]
  356.         if {[llength $res] > 2} {
  357.             set theotherflags [lrange [lindex $res 2] 1 end]
  358.             if {[lindex [lindex $res 2] 0] != -1} {
  359.             set mproc [lindex [lindex $res 2] 0]
  360.             }
  361.             if {[lindex $res 3] != ""} {
  362.             eval lappend msubs [lindex $res 3]
  363.             }
  364.             if {[lindex $res 4] != ""} { set name [lindex $res 4] }
  365.         }
  366.         } "menu" - "Menu" {
  367.         eval $res
  368.         menu::postEval $token
  369.         return ""
  370.         } default {
  371.         menu::postEval $token
  372.         return ""
  373.         }
  374.     }
  375.     } else {
  376.     set ma ""
  377.     if {[info exists menu::items($token)]} {
  378.         set ma [set menu::items($token)]
  379.         global menu::proc menu::which_subs menu::otherflags
  380.         if {[info exists menu::proc($token)]} {
  381.         set mproc [set menu::proc($token)]
  382.         }
  383.         if {[info exists menu::which_subs($token)]} {
  384.         eval lappend msubs [set menu::which_subs($token)]
  385.         }
  386.         if {[info exists menu::otherflags($token)]} {
  387.         set theotherflags [set menu::otherflags($token)]
  388.         }
  389.     }
  390.     }
  391.  
  392.     if {![info exists name]} { set name $token }
  393.     # add any registered items and make the menu contents
  394.     if {[info exists menu::additions($token)]} {
  395.     foreach ins [set menu::additions($token)] {
  396.         set where [lindex $ins 1]
  397.         set type [lindex $ins 0]
  398.         set ins [lrange $ins 2 end]
  399.         switch -- $type {
  400.         "submenu" {
  401.             lappend msubs [lindex $ins 0]
  402.             set ins [list [list Menu -n [lindex $ins 0] {}]]
  403.         }
  404.         }
  405.         switch -- [lindex $where 0] {
  406.         "replace" {
  407.             set old [lindex $where 1]
  408.             if {[set ix [eval llindex ma $old]] != -1} {
  409.             set ma [eval [list lreplace $ma $ix [expr {$ix -1 + [llength $old]}]] $ins]
  410.             } else {
  411.             alertnote "Bad menu::replacement registered '$old'"
  412.             }
  413.             
  414.         }
  415.         "end" {
  416.             eval lappend ma $ins
  417.         }
  418.         default {
  419.             set ma [eval linsert [list $ma] $where $ins]
  420.         }
  421.         }
  422.     }
  423.     }
  424.     # These two lines removed due to some conflicts
  425.     #    regsub -all {"?\(-"?([ \t\r\n]+"?\(-"?)+} $ma "(-" ma
  426.     #    regsub -all {(^[ \t\r\n]*"?\(-"?|"?\(-"?[ \t\r\n]*$)} $ma "" ma
  427.  
  428.     # build the menu
  429.     set name [list -n $name]
  430.     if {[info exists theotherflags]} {
  431.     set name [concat $theotherflags $name]
  432.     }
  433.     if {[info tclversion] >= 8.0} {
  434.     lappend name -h [list "This is the [lindex $name end] menu"]
  435.     }
  436.     if {[info exists mproc]} {
  437.     if {$mproc != ""} {
  438.         eval Menu $name -p $mproc [list $ma]
  439.     } else {
  440.         eval Menu $name [list $ma]
  441.     }
  442.     } else {
  443.     eval Menu $name -p menu::generalProc [list $ma]
  444.     }
  445.     menu::postEval $token
  446.     if {[info exists msubs]} {
  447.     return $msubs
  448.     }
  449.     return ""
  450. }
  451.  
  452. proc menu::postEval {name} {
  453.     global menu::posteval
  454.     if {[info exists menu::posteval($name)]} {
  455.     catch {uplevel \#0 [set menu::posteval($name)]}
  456.     }
  457. }
  458.  
  459. proc menu::replaceRebuild {name title} {
  460.     global $name
  461.     catch {removeMenu [set $name]}
  462.     set $name $title
  463.     menu::buildSome $name
  464.     insertMenu [set $name]
  465. }
  466.  
  467. proc menu::packagesBuild {} {
  468.     global alpha::package_menus package::prefs
  469.     lappend ma [menu::itemWithIcon "packagePreferences" 84] \
  470.       "miscellaneousPackages…"
  471.     if {[info exists package::prefs]} {
  472.     foreach pkg ${package::prefs} {
  473.         lappend ma "${pkg}Prefs…"
  474.     }
  475.     }
  476.     lappend ma "(-" "describeAPackage…" "readHelpForAPackage…" \
  477.       "uninstallSomePackages…" \
  478.       {Menu -m -n internetUpdates -p package::menuProc {}} \
  479.       "(-" "rebuildPackageIndices"
  480.     return [list build $ma menu::packagesProc internetUpdates]
  481. }
  482.  
  483. proc menu::packagesProc {menu item} {
  484.     global package::prefs
  485.     if {[regexp "(.*)Prefs" $item d pkg]} {
  486.     if {[lcontains package::prefs $pkg]} {
  487.         dialog::pkg_options $pkg
  488.         return
  489.     }
  490.     }
  491.     switch -- $item {
  492.     "miscellaneousPackages" {
  493.         return [dialog::preferences $menu Packages]
  494.     }
  495.     "describeAPackage" -
  496.     "Describe A Package" {
  497.         set pkg [dialog::optionMenu "Describe which package?" \
  498.           [lsort -ignore [alpha::package names]]]
  499.         package::describe $pkg
  500.     }
  501.     "readHelpForAPackage" -
  502.     "Read Help For A Package" {
  503.         set pkg [dialog::optionMenu "Read help for which package?" \
  504.           [lsort -ignore [alpha::package names]]]
  505.         package::helpFile $pkg
  506.     }
  507.     "uninstallSomePackages" -
  508.     "Uninstall Some Packages" {
  509.         package::uninstall
  510.     }
  511.     "rebuildPackageIndex" {
  512.         alpha::rebuildPackageIndices
  513.     }
  514.     "packagePreferences" {
  515.         alertnote "Select a package from the group below in the menu to\
  516.           edit its preferences."
  517.     }
  518.     default {
  519.         menu::generalProc global $item
  520.     }
  521.     }
  522. }
  523.  
  524.  
  525. proc menu::menuPackages {menu m} {
  526.     if {[package::helpOrDescribe $m]} {
  527.     return
  528.     }
  529.     # toggle global existence of '$m' menu
  530.     global global::menus modifiedVars
  531.     if {[set idx [lsearch  ${global::menus} $m]] == -1} {
  532.     lappend global::menus $m
  533.     global $m
  534.     catch $m
  535.     insertMenu [set    $m]
  536.     markMenuItem packageMenus $m 1
  537.     } else {
  538.     set global::menus [lreplace ${global::menus} $idx $idx]
  539.     global $m
  540.     catch "removeMenu [set $m]"
  541.     markMenuItem packageMenus $m 0
  542.     }
  543.     lappend modifiedVars global::menus
  544. }
  545.  
  546. if {[info tclversion] < 8.0} {
  547.     proc menu::modeBuild {} {
  548.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  549.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  550.     return [list build $ma mode::menuProc "" "Mode Prefs"]
  551.     }
  552. } else {
  553.     proc menu::modeBuild {} {
  554.     global mode
  555.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  556.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  557.     if {$mode != ""} {
  558.         return [list build $ma mode::menuProc "" "${mode} Mode Prefs"]
  559.     } else {
  560.         return [list build $ma mode::menuProc "" "Mode Prefs"]
  561.     }
  562.     }
  563. }
  564.  
  565. proc menu::preferencesBuild {} {
  566.     global flagPrefs
  567.     
  568.     set ma [list "/p<U<BMenus And Features…" "/p<USuffix Mappings…" \
  569.       "Save Preferences Now" "Edit Prefs File" "(-" \
  570.       [menu::itemWithIcon "Interface Preferences" 84]]
  571.     lappend ma Appearance Electrics Text Tiling Window "(-" \
  572.       [menu::itemWithIcon "Input-Output Preferences" 84]
  573.     lappend ma Backups Files Printer Tags WWW "(-" \
  574.       [menu::itemWithIcon "System Preferences" 84]
  575.     eval lunion ma [lsort [lremove [array names flagPrefs] Packages]]
  576.     return [list build $ma {dialog::preferences -m}]
  577. }
  578.  
  579. proc menu::removeFrom {name args} {
  580.     global menu::additions alpha::noMenusYet
  581.     if {[info exists menu::additions($name)]} {
  582.     if {[set i [lsearch -exact [set menu::additions($name)] $args]] != -1} {
  583.         set menu::additions($name) [lreplace [set menu::additions($name)] $i $i]
  584.         if {![info exists alpha::noMenusYet]} {
  585.         # we were called after start-up; build the menu now
  586.         menu::buildSome $name
  587.         }
  588.     }
  589.     }
  590. }
  591.  
  592. proc menu::replaceWith {name current type args} {
  593.     global menu::additions alpha::noMenusYet
  594.     if {![info exists menu::additions($name)]} {
  595.     lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  596.     } else {
  597.     set add 1
  598.     set j 0
  599.     foreach i [set menu::additions($name)] {
  600.         if {[lrange $i 0 1] == [list $type [list replace $current]]} {
  601.         if {[lindex $i 1] != $args} {
  602.             set add 0
  603.             set menu::additions($name) \
  604.               [lreplace [set menu::additions($name)] $j $j \
  605.               [concat [list $type [list replace $current]] $args]]
  606.             break
  607.         } else {
  608.             # no change
  609.             return
  610.         }
  611.         }
  612.         incr j
  613.     }
  614.     if {$add} {
  615.         lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  616.     }
  617.     }
  618.     if {![info exists alpha::noMenusYet]} {
  619.     # we were called after start-up; build the menu now
  620.     menu::buildSome $name
  621.     }
  622. }
  623.  
  624. proc menu::itemWithIcon {name icon} {
  625.     return "/\x1e${name}^[text::Ascii $icon 1]"
  626. }
  627.  
  628. proc menu::fileProc {menu item} {
  629.     switch -- $item {
  630.     "open" {
  631.         findFile
  632.     }
  633.     "close" {
  634.         killWindow
  635.     }
  636.     default {
  637.         uplevel 1 [list menu::generalProc file $item]
  638.     }
  639.     }
  640. }
  641.  
  642. ## 
  643.  # -------------------------------------------------------------------------
  644.  # 
  645.  # "menu::generalProc" --
  646.  # 
  647.  #  If either 'item' or 'menu::item' exists, call it.  Else try and
  648.  #  autoload 'item', if that fails try and autoload 'menu::item'
  649.  # -------------------------------------------------------------------------
  650.  ##
  651. if {[info tclversion] < 8.0} {
  652.     proc menu::generalProc {menu item {lower 1}} {
  653.     if {$lower} {set menu [string tolower $menu]}
  654.     if {[info commands ${menu}::${item}] != ""} {
  655.         uplevel \#0 ${menu}::$item
  656.     } elseif {[info commands $item] != ""} {
  657.         uplevel \#0 $item
  658.     } elseif {[auto_load ${menu}::$item]} {
  659.         uplevel \#0 ${menu}::$item
  660.     } else {
  661.         uplevel \#0 $item
  662.     }
  663.     }
  664. } else {
  665.     proc menu::generalProc {menu item {lower 1}} {
  666.     if {$lower} {set menu [string tolower $menu]}
  667.     if {[info commands ::${menu}::${item}] != ""} {
  668.         uplevel \#0 ::${menu}::$item
  669.     } elseif {[info commands $item] != ""} {
  670.         uplevel \#0 $item
  671.     } elseif {[auto_load ::${menu}::$item]} {
  672.         uplevel \#0 ::${menu}::$item
  673.     } else {
  674.         uplevel \#0 $item
  675.     }
  676.     }
  677. }
  678.  
  679. proc menu::globalProc {menu item} {
  680.     menu::generalProc global $item
  681. }
  682.  
  683. proc menu::winProc {menu name} {
  684.     global winNameToNum
  685.  
  686.     set nms [array names winNameToNum]
  687.  
  688.     if {[lsearch -glob $nms "*[quote::Find $name]"] < 0} {
  689.         $name
  690.         return
  691.     }
  692.  
  693.     foreach nm $nms {
  694.         if {[string match *[quote::Find $name] $nm] == "1"}  {
  695.             bringToFront $name
  696.             if {[icon -q]} { icon -f $name -o }
  697.             return
  698.         }
  699.     }
  700.     return "normal"
  701. }
  702.  
  703.  
  704. ## 
  705.  # proc namedClipMenuProc {menu item} {
  706.  #     switch $item {
  707.  #         "copy"      "copyNamedClipboard"
  708.  #         "cut"       "cutNamedClipboard"
  709.  #         "paste"     "pasteNamedClipboard"
  710.  #     }
  711.  # }
  712.  ##
  713.  
  714. proc menu::colorProc {menu item} {
  715.     global colorInds modifiedArrVars
  716.     if {[info exists colorInds($item)]} {
  717.     set color [eval [list colorTriple "New \"$item\":"] $colorInds($item)]
  718.     } else {
  719.     switch -- $item {
  720.         foreground    { set inds "0 0 0" }
  721.         background    { set inds "65535 65535 65535" }
  722.         blue        { set inds "0 0 65535" }
  723.         cyan        { set inds "61404 11464 34250" }
  724.         green        { set inds "1151 33551 8297" }
  725.         magenta        { set inds "44790 1591 51333" }
  726.         red            { set inds "65535 0 0" }
  727.         white        { set inds "65535 65535 65535" }
  728.         yellow        { set inds "61834 64156 12512" }
  729.         default        { set inds "65535 65535 65535" }
  730.     }
  731.     set color [eval [list colorTriple "New \"$item\":"] $inds]
  732.     }
  733.     eval setRGB $item $color
  734.     
  735.     set colorInds($item) $color
  736.     alpha::makeColourList
  737.     lappend modifiedArrVars colorInds
  738. }
  739.  
  740. proc alpha::makeColourList {} {
  741.     global alpha::colors colorInds alpha::basiccolors
  742.     # Set up color indices
  743.     foreach ind [array names colorInds] {
  744.     eval setRGB $ind $colorInds($ind)
  745.     }
  746.     set alpha::basiccolors {none blue cyan green magenta red white yellow}
  747.     set alpha::colors ${alpha::basiccolors}
  748.     foreach c {color_9 color_10 color_11 color_12 color_13 color_14 color_15} {
  749.     if {[info exists colorInds($c)]} {lappend alpha::colors $c}
  750.     }
  751. }
  752.  
  753.  
  754.         
  755. #===============================================================================
  756. proc helpMenu {item} {
  757.     global HOME
  758.     edit -r -c [file join $HOME Help $item]
  759. }
  760.  
  761. ## 
  762.  # -------------------------------------------------------------------------
  763.  # 
  764.  # "alphaHelp" --
  765.  # 
  766.  #  Called from about box
  767.  # -------------------------------------------------------------------------
  768.  ##
  769. proc alphaHelp {} {
  770.     global HOME
  771.     if {[file exists [set f [file join ${HOME} Help "Alpha Manual"]]]} {
  772.     edit -r -c $f
  773.     } else {
  774.     edit -r -c [file join $HOME Help "Quick Start"]
  775.     }
  776. }
  777.  
  778. proc register {} {
  779.     global HOME
  780.     launch -f [file join $HOME Register]
  781. }
  782.  
  783. namespace eval icon {}
  784. namespace eval file {}
  785.  
  786. proc icon::FromSig {sig} {
  787.     global alpha::_icons
  788.     if {[set p [lsearch -glob ${alpha::_icons} "[quote::Find ${sig}] *"]] != -1} {
  789.     set p [lindex ${alpha::_icons} $p]
  790.     return [lindex $p 2]
  791.     } else {
  792.     return ""
  793.     }
  794. }
  795.  
  796. proc icon::MenuFromSig {sig} {
  797.     global alpha::_icons
  798.     if {[set p [lsearch -glob ${alpha::_icons} "[quote::Find ${sig}] *"]] != -1} {
  799.     set char [expr {[lindex [lindex ${alpha::_icons} $p] 2] -208}]
  800.     if {$char < 1 || $char > 256} { return "" }
  801.     return "^[text::Ascii $char 1]"
  802.     } else {
  803.     return ""
  804.     }
  805. }
  806.  
  807.  
  808. proc menu::fileUtils {menu item} {
  809.     if {[lsearch -exact {"insertPathName" "insertFile" "fileRemove" "fileInfo" "wordCount" "textToAlpha"} $item] != -1} {return [$item]}
  810.     switch -- $menu {
  811.     "moreUtils" {
  812.         file::Utils::$item
  813.     }
  814.     default {
  815.         file::$item
  816.     }
  817.     }
  818. }
  819.  
  820. proc menu::winTileProc {menu item} {
  821.     win$item
  822. }
  823.  
  824. ## 
  825.  # -------------------------------------------------------------------------
  826.  # 
  827.  #    "menu::buildHierarchy" --
  828.  # 
  829.  #  Given a list of folders, 'menu::buildHierarchy' returns a hierarchical
  830.  #  menu based on the files and subfolders in each of these folders. 
  831.  #  Pathnames are optionally stored in a global array given by the argument
  832.  #  'filePaths'.  The path's index in this array is formed by concatenating
  833.  #  the submenu name and the filename, allowing the pathname to be
  834.  #  retrieved by the procedure 'proc' when the menu item is selected.
  835.  # 
  836.  #  The search may be restricted to files with specific extensions, or
  837.  #  files matching a certain pattern.  A search depth may also be given,
  838.  #  with three levels of subfolders assumed by default.
  839.  # 
  840.  #  See MacPerl.tcl or latexMenu.tcl for examples.
  841.  # 
  842.  #  (originally written by Tom Pollard, with modifications by Vince Darley
  843.  #  and Tom Scavo)
  844.  # 
  845.  # --Version--Author------------------Changes-------------------------------
  846.  #      1.0      Tom Pollard                    original
  847.  #      2.0      <vince@santafe.edu> multiple extensions, optional    paths
  848.  #      2.1      Tom Scavo                        multiple folders
  849.  #      2.2      <vince@santafe.edu> pattern matching as well as exts
  850.  #      2.3      <vince@santafe.edu> handles unique menu-names and does text only
  851.  #      2.4      <jl@theophys.kth.se>    now also handles patterns like "*.{a,b}"
  852.  # -------------------------------------------------------------------------
  853.  ##
  854. proc menu::buildHierarchy {folders name proc {filePaths {}} {exts *} {depth 3} {fset {}}} {
  855.     global filesetmodeVars file::separator
  856.     if { $filePaths != "" } {
  857.     global $filePaths
  858.     }
  859.     if {[llength $exts] > 1} {
  860.     regsub -all {\.} $exts "" exts
  861.     set exts "*.{[join $exts ,]}"
  862.     } elseif {[string match ".*" $exts] && ![string match {*\**} $exts]} {set exts "*$exts"}
  863.     incr depth -1
  864.     set overallMenu {}
  865.     foreach folder $folders {
  866.     if {[file exists $folder]} {
  867.         if {![file isdirectory $folder]} {
  868.         set folder "[file dirname $folder]${file::separator}"
  869.         }
  870.         if {![regexp -- "${file::separator}$" $folder]} {
  871.         set folder "$folder${file::separator}"
  872.         }
  873.         if {$name == 0} {
  874.         set name [file tail [file dirname ${folder}dummy]]
  875.         }
  876.         # if it's a fileset, we register _before_ recursing
  877.         if { $fset != "" } {
  878.         set mname [registerFilesetMenuName $fset $name $proc]
  879.         } else {
  880.         set mname $name
  881.         }
  882.         set menu {}
  883.         set subfolders [glob -nocomplain -t d -path $folder *]
  884.         if {$filesetmodeVars(includeNonTextFiles)} {
  885.         set filenames [glob -nocomplain -path $folder -- $exts]
  886.         } else {
  887.         set filenames [glob -t TEXT -nocomplain -path $folder $exts]
  888.         }
  889.         # Note that the list of filenames may also contain some/all
  890.         # subfolders (if they matched the glob expression), hence
  891.         # we must be sure not to add them twice.
  892.         foreach m [lsort -ignore [concat $subfolders $filenames]] {
  893.         if {[set s [lsearch -exact $subfolders $m]] != -1 && $depth > 0} {
  894.             set subM [menu::buildHierarchy [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  895.             if {[llength $subM]} { lappend menu $subM }
  896.         } elseif {[file isfile $m]} {
  897.             lappend menu [set fname [file tail $m]]
  898.             if { $filePaths != "" } {
  899.             set ${filePaths}([file join $name $fname]) $m
  900.             }
  901.         }
  902.         }
  903.         
  904.         if {[llength $menu]} {
  905.         set overallMenu [concat $overallMenu $menu]
  906.         }
  907.     } else {
  908.         beep
  909.         alertnote "menu::buildHierarchy:  Folder $folder does not exist!"
  910.     }
  911.     }
  912.     
  913.     if {[llength $overallMenu]} {
  914.     if { [string length $proc] > 1 } {
  915.         set pproc "-p $proc"
  916.     } else {
  917.         set pproc ""
  918.     }    
  919.     if { $fset != "" } {
  920.         if { [string length $proc] > 1 } { set pproc "-p subMenuProc" }
  921.     }     
  922.     return [concat {Menu -m -n} [list $mname] $pproc [list $overallMenu]]
  923.     
  924.     } else {
  925.     return ""
  926.     }
  927. }
  928.  
  929. # in case we've done something odd elsewhere
  930. ensureset filesetmodeVars(includeNonTextFiles) 0
  931.  
  932.  
  933. proc menu::reinterpretOldMenu {args} {
  934.     set ma [lindex $args end]
  935.     set args [lreplace $args end end]
  936.     getOpts {-n -M -p}
  937.     if {[info exists opts(-p)]} {
  938.     lappend proc $opts(-p)
  939.     } else {
  940.     lappend proc "-1"
  941.     }
  942.     if {[info exists opts(-M)]} { lappend proc -M $opts(-m) }
  943.     if {[info exists opts(-m)]} { lappend proc -m }
  944.     menu::buildOne $opts(-n) build $ma $proc
  945. }
  946.  
  947.  
  948.  
  949.  
  950.